open C_lexical;;

module type StreamType = sig
	type 'a t;;
	val next: 'a t -> 'a;;
	exception Failure;;
end;;

module Scanner (Integer: NumericType) (Real: NumericType) (WideString: StringType with type elm = int32)
	(LexicalElement: LexicalElementType with type integer = Integer.t and type real = Real.t and type wide_string = WideString.t)
	(Input: StreamType) =
struct
	
	type text_file_position = string * int;;
	
	type t = {
		mutable filename: string;
		mutable line: int;
		mutable tokens_in_line: int;
		mutable tokens: (LexicalElement.t * text_file_position) Queue.t;
		mutable h: char;
		mutable in_macro: bool;
		objc: bool;
		cpp: bool;
		source: char Input.t};;
	
	let create ?(objc: bool = false) ?(cpp: bool = false) (filename: string) (s: char Input.t): t = (
		{filename = filename; line = 1; tokens_in_line = 0;
			tokens = Queue.create (); h = ' '; in_macro = false;
			objc = objc; cpp = cpp; source = s}
	);;
	
	module Private = struct
		
		let current_position it = (
			(it.filename, it.line)
		);;
		
		let take it: unit = (
			try it.h <- Input.next it.source
			with Input.Failure -> it.h <- '\x1a'
		);;
		
		let skip_spaces ?(in_line = false) it: unit = (
			while (
				if it.h = ' ' || it.h = '\t' || it.h = '\x0b' then (
					take it;
					true
				) else if in_line || it.in_macro then (
					false
				) else if it.h = '\r' then (
					it.line <- it.line + 1;
					take it;
					if it.h = '\n' then take it;
					it.tokens_in_line <- 0;
					true
				) else if it.h = '\n' || it.h = '\x0c' then (
					it.line <- it.line + 1;
					it.tokens_in_line <- 0;
					take it;
					true
				) else (
					false
				)
			) do
				()
			done
		);;
		
		let add_error it (message: string) (position: text_file_position): unit = (
			Queue.add (LexicalElement.Lexical_error message, position) it.tokens
		);;
		
		let add_unexpected_error it c p: unit = (
			add_error it ("\'" ^ String.make 1 c ^ "\' is bad character.") p
		);;
		
		let add it (e: LexicalElement.t) (position: text_file_position): unit = (
			it.tokens_in_line <- it.tokens_in_line + 1;
			Queue.add (e, position) it.tokens
		);;
		
		let read_line it: string = (
			let b = Buffer.create 16 in
			while (
				match it.h with
				| '\n' | '\r' | '\x0c' | '\x1a' -> false
				| _ -> true
			) do
				Buffer.add_char b it.h;
				take it
			done;
			Buffer.contents b
		);;
		
		let read_word it: string = (
			let b = Buffer.create 16 in
			Buffer.add_char b it.h;
			while (take it; match it.h with 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true | _ -> false) do
				Buffer.add_char b it.h
			done;
			Buffer.contents b
		);;
		
		let read_digits it ~(base: int): string = (
			let b = Buffer.create 16 in
			while (
				match it.h with
				| '0'..'9' when Char.code it.h - Char.code '0' < base -> true
				| 'A'..'F' | 'a'..'f' when base = 16 -> true
				| _ -> false
			) do
				Buffer.add_char b it.h;
				take it;
			done;
			Buffer.contents b
		);;
		
		let read_string it ~(quote: char): string = (
			assert (it.h = quote);
			take it;
			let rec loop it b = (
				begin match it.h with
				| '\\' ->
					take it;
					begin match it.h with
					| '0' ->
						Buffer.add_char b '\x00';
						take it
					| 'a' ->
						Buffer.add_char b '\x07';
						take it
					| 'b' ->
						Buffer.add_char b '\x08';
						take it
					| 'f' ->
						Buffer.add_char b '\x0c';
						take it
					| 'n' ->
						Buffer.add_char b '\n';
						take it
					| 'r' ->
						Buffer.add_char b '\r';
						take it
					| 't' ->
						Buffer.add_char b '\t';
						take it
					| 'v' ->
						Buffer.add_char b '\x0b';
						take it
					| 'x' ->
						take it;
						let r = ref 0 in
						while (
							r := !r * 16;
							begin match it.h with
							| '0'..'9' -> r := !r + (Char.code it.h - Char.code '0'); true
							| 'A'..'F' -> r := !r + (Char.code it.h - (Char.code 'A' - 10)); true
							| 'a'..'f' -> r := !r + (Char.code it.h - (Char.code 'a' - 10)); true
							| _ -> false
							end
						) do () done;
						Buffer.add_char b (Char.chr !r);
						take it
					| _ ->
						Buffer.add_char b it.h;
						take it
					end;
					loop it b
				| '\n' | '\r' | '\x0c' | '\x1a' ->
					add_error it ("'" ^ String.make 1 quote ^ "' expected.") (current_position it);
					Buffer.contents b
				| h when h = quote ->
					take it;
					Buffer.contents b
				| _ ->
					Buffer.add_char b it.h;
					take it;
					loop it b
				end
			) in
			loop it (Buffer.create 0)
		);;
		
		let rec scan_after_percent it (p1: text_file_position): unit = (
			begin match it.h with
			| ':' ->
				take it;
				begin match it.h with
				| '%' ->
					let p2 = current_position it in
					take it;
					begin match it.h with
					| ':' ->
						take it;
						add it LexicalElement.D_sharp p1
					| _ ->
						add it LexicalElement.Sharp p1;
						scan_after_percent it p2
					end
				| _ ->
					add it LexicalElement.Sharp p1
				end
			| '>' ->
				take it;
				add it LexicalElement.R_curly p1
			| '=' ->
				take it;
				add it LexicalElement.Rem_assign p1
			| _ ->
				add it LexicalElement.Percent p1
			end
		);;
		
		let rec scan it: unit = (
			skip_spaces it;
			
			begin match it.h with
			| '(' ->
				add it LexicalElement.L_paren (current_position it);
				take it
			| ')' ->
				add it LexicalElement.R_paren (current_position it);
				take it
			| '[' ->
				add it LexicalElement.L_bracket (current_position it);
				take it
			| ']' ->
				add it LexicalElement.R_bracket (current_position it);
				take it
			| '{' ->
				add it LexicalElement.L_curly (current_position it);
				take it
			| '}' ->
				add it LexicalElement.R_curly (current_position it);
				take it
			| '~' ->
				add it LexicalElement.Tilde (current_position it);
				take it
			| '?' ->
				add it LexicalElement.Question (current_position it);
				take it
			| ',' ->
				add it LexicalElement.Comma (current_position it);
				take it
			| ';' ->
				add it LexicalElement.Semicolon (current_position it);
				take it
			| '.' ->
				let p1 = current_position it in
				take it;
				begin match it.h with
				| '.' ->
					let p2 = current_position it in
					take it;
					begin match it.h with
					| '.' ->
						take it;
						add it LexicalElement.Varargs p1
					| _ ->
						add it LexicalElement.Period p1;
						add it LexicalElement.Period p2
					end
				| '*' when it.cpp ->
					add it LexicalElement.Period_ref p1
				| _ ->
					add it LexicalElement.Period p1
				end
			| ':' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '>' ->
					take it;
					add it LexicalElement.R_bracket p
				| ':' when it.cpp ->
					take it;
					add it LexicalElement.D_colon p
				| _ ->
					add it LexicalElement.Colon p
				end
			| '<' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| ':' ->
					take it;
					add it LexicalElement.L_bracket p
				| '%' ->
					take it;
					add it LexicalElement.L_curly p
				| '<' ->
					take it;
					begin match it.h with
					| '=' ->
						take it;
						add it LexicalElement.L_shift_assign p
					| _ ->
						add it LexicalElement.L_shift p
					end
				| '=' ->
					take it;
					add it LexicalElement.LE p
				| _ ->
					add it LexicalElement.LT p
				end
			| '>' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '>' ->
					take it;
					begin match it.h with
					| '=' ->
						take it;
						add it LexicalElement.R_shift_assign p
					| _ ->
						add it LexicalElement.R_shift p
					end
				| '=' ->
					take it;
					add it LexicalElement.GE p
				| _ ->
					add it LexicalElement.GT p
				end
			| '-' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '>' ->
					take it;
					begin match it.h with
					| '*' when it.cpp ->
						add it LexicalElement.Arrow_ref p
					| _ ->
						add it LexicalElement.Arrow p
					end
				| '-' ->
					take it;
					add it LexicalElement.Decrement p
				| '=' ->
					take it;
					add it LexicalElement.Sub_assign p
				| _ ->
					add it LexicalElement.Minus p
				end
			| '+' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '+' ->
					take it;
					add it LexicalElement.Increment p
				| '=' ->
					take it;
					add it LexicalElement.Add_assign p
				| _ ->
					add it LexicalElement.Plus p
				end
			| '*' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '=' ->
					take it;
					add it LexicalElement.Mul_assign p
				| _ ->
					add it LexicalElement.Asterisk p
				end
			| '/' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '/' ->
					while (
						take it;
						match it.h with
						| '\n' | '\r' | '\x0c' | '\x1a' -> false
						| _ -> true
					) do
						()
					done;
					scan it
				| '=' ->
					take it;
					add it LexicalElement.Div_assign p
				| '*' ->
					add_error it ("/* ... */ style comment is not implemented yet.") p;
					add it LexicalElement.Slash p;
					add it LexicalElement.Asterisk (current_position it);
					take it
				| _ ->
					add it LexicalElement.Slash p
				end
			| '%' ->
				let p = current_position it in
				take it;
				scan_after_percent it p
			| '^' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '=' ->
					take it;
					add it LexicalElement.Xor_assign p
				| _ ->
					add it LexicalElement.Caret p
				end
			| '|' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '|' ->
					take it;
					add it LexicalElement.Or p
				| '=' ->
					take it;
					add it LexicalElement.Or_assign p
				| _ ->
					add it LexicalElement.Vertical p
				end
			| '&' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '&' ->
					take it;
					add it LexicalElement.And p
				| '=' ->
					take it;
					add it LexicalElement.And_assign p
				| _ ->
					add it LexicalElement.Ampersand p
				end
			| '!' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '=' ->
					take it;
					add it LexicalElement.NE p
				| _ ->
					add it LexicalElement.Exclamation p
				end
			| '=' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '=' ->
					take it;
					add it LexicalElement.EQ p
				| _ ->
					add it LexicalElement.Assign p
				end
			| '#' ->
				let first_of_line = it.tokens_in_line = 0 in
				let p = current_position it in
				take it;
				begin match it.h with
				| '#' ->
					take it;
					add it LexicalElement.D_sharp p
				| _ ->
					if first_of_line then (
						(* preprocessor directive *)
						assert (not it.in_macro);
						skip_spaces ~in_line:true it;
						begin match it.h with
						| '0'..'9' ->
							let l = int_of_string (read_digits it ~base:10) in
							skip_spaces ~in_line:true it;
							let f = read_string it ~quote:'\"' in
							skip_spaces ~in_line:true it;
							while (match it.h with | '0'..'9' -> true | _ -> false) do
								let mark = int_of_string (read_digits it ~base:10) in
								begin match mark with
								| 1 -> add it (LexicalElement.Include_begin f) p
								| 2 -> add it LexicalElement.Include_end (f, l)
								| _ -> ()
								end;
								skip_spaces ~in_line:true it
							done;
							let (_: string) = read_line it in
							it.line <- l - 1;
							it.filename <- f;
							scan it
						| 'A'..'Z' | 'a'..'z' | '_' ->
							let dir = read_word it in
							begin match dir with
							| "define" ->
								skip_spaces ~in_line:true it;
								let name = read_word it in
								let args = (
									if it.h = '(' then (
										take it;
										let rec get_args rs = (
											skip_spaces ~in_line:true it;
											begin match it.h with
											| ')' ->
												take it;
												rs
											| '\n' | '\r' | '\x0c' | '\x1a' ->
												add_error it ("\')\' expected.") p;
												rs
											| 'A'..'Z' | 'a'..'z' | '_' | ',' ->
												if rs <> [] then (
													if it.h = ',' then (
														take it;
														skip_spaces ~in_line:true it
													) else (
														add_error it ("\',\' expected.") p
													)
												) else if it.h = ',' then (
													add_unexpected_error it ',' p
												);
												let arg = read_word it in
												get_args (arg :: rs)
											| _ ->
												add_unexpected_error it it.h p;
												take it;
												get_args rs
											end
										) in
										List.rev (get_args [])
									) else (
										[]
									)
								) in
								let original_queue = it.tokens in
								it.tokens <- Queue.create ();
								it.in_macro <- true;
								skip_spaces ~in_line:true it;
								let rec get_tokens rs = (
									if Queue.is_empty it.tokens then (
										scan it
									);
									let (t, _) = Queue.take it.tokens in
									if t = LexicalElement.Eof then (
										rs
									) else (
										get_tokens (t :: rs)
									)
								) in
								let tokens = List.rev (get_tokens []) in
								it.in_macro <- false;
								it.tokens <- original_queue;
								let def = (
									if it.filename = "<built-in>" then (
										LexicalElement.DEFINE_predefined (name, args, tokens)
									) else (
										LexicalElement.DEFINE (name, args, tokens)
									)
								) in
								add it (LexicalElement.Preprocessor_directive def) p
							| "undef" ->
								skip_spaces ~in_line:true it;
								let name = read_word it in
								let (_: string) = read_line it in
								add it (LexicalElement.Preprocessor_directive (LexicalElement.UNDEF name)) p
							| _ ->
								let rest = read_line it in
								add it (LexicalElement.Preprocessor_directive (LexicalElement.Unknown (dir ^ rest))) p
							end
						| _ -> (* error *)
							let s = read_line it in
							add_error it ("Bad preorpcessor directive \"" ^ String.escaped s ^ "\"") p
						end
					) else (
						add it LexicalElement.Sharp p
					)
				end
			| '\'' ->
				let p = current_position it in
				let s = read_string it ~quote:'\'' in
				if String.length s = 1 then (
					add it (LexicalElement.Char_literal s.[0]) p
				) else (
					add_error it "Length of char literal should be 1" p;
					add it LexicalElement.Invalid_literal p
				)
			| '\"' ->
				let p = current_position it in
				let s = read_string it ~quote:'\"' in
				add it (LexicalElement.Chars_literal s) p
			| '0'..'9' ->
				let p = current_position it in
				let base = (
					if it.h = '0' then (
						take it;
						if it.h = 'x' then (
							take it;
							16
						) else (
							8
						)
					) else (
						10
					)
				) in
				let integer_part = (
					let s = read_digits it ~base:base in
					if s = "" && base = 8 then "0" else s
				) in
				begin match it.h with
				| '.' | 'e' | 'E' ->
					let v = (
						if it.h = '.' then (
							take it;
							let decimal_part = read_digits it ~base:base in
							Real.of_basedstring ~base (integer_part ^ "." ^ decimal_part)
						) else (
							Real.of_basedstring ~base integer_part
						)
					) in
					let v = (
						if it.h = 'e' || it.h = 'E' then (
							take it;
							let sign = (
								match it.h with
								| '+' -> take it; 1
								| '-' -> take it; -1
								| _ -> 1
							) in
							let e = int_of_string (read_digits it ~base:10) in
							Real.scaling ~base:10 ~adjustment:(sign * e) v
						) else (
							v
						)
					) in
					let size = (
						match it.h with
						| 'd' | 'D' ->
							take it;
							begin match it.h with
							| 'f' | 'F' -> take it; LexicalElement.Decimal32
							| 'd' | 'D' -> take it; LexicalElement.Decimal64
							| 'l' | 'L' -> take it; LexicalElement.Decimal128
							| _ ->
								add_error it "DF or DD or DL expected for gcc\'s decimal float." (current_position it);
								LexicalElement.Decimal32
							end
						| 'f' | 'F' -> take it; LexicalElement.Float
						| 'l' | 'L' -> take it; LexicalElement.Long_double_float
						| _ -> LexicalElement.Double_float
					) in
					add it (LexicalElement.Float_literal (size, v)) p
				| 'L' | 'l' ->
					take it;
					begin match it.h with
					| 'L' | 'l' ->
						take it;
						let v = Integer.of_basedstring ~base integer_part in
						add it (LexicalElement.Int_literal (LexicalElement.Signed_long_long, v)) p
					| _ ->
						let v = Integer.of_basedstring ~base integer_part in
						add it (LexicalElement.Int_literal (LexicalElement.Signed_long, v)) p
					end
				| 'U' | 'u' ->
					take it;
					begin match it.h with
					| 'L' | 'l' ->
						take it;
						begin match it.h with
						| 'L' | 'l' ->
							take it;
							let v = Integer.of_basedstring ~base integer_part in
							add it (LexicalElement.Int_literal (LexicalElement.Signed_long_long, v)) p
						| _ ->
							let v = Integer.of_basedstring ~base integer_part in
							add it (LexicalElement.Int_literal (LexicalElement.Signed_long, v)) p
						end
					| _ ->
						let v = Integer.of_basedstring ~base integer_part in
						add it (LexicalElement.Int_literal (LexicalElement.Unsigned_int, v)) p
					end
				| _ ->
					let v = Integer.of_basedstring ~base integer_part in
					add it (LexicalElement.Int_literal (LexicalElement.Signed_int, v)) p
				end
			| 'A'..'Z' | 'a'..'z' | '_' ->
				let p = current_position it in
				let s = read_word it in
				let table = (
					if it.objc && it.cpp then (
						Reserved.allrw_of_string_table
					) else if it.objc then (
						Reserved.objcrw_of_string_table
					) else if it.cpp then (
						Reserved.cpprw_of_string_table
					) else (
						Reserved.crw_of_string_table
					)
				) in
				if Hashtbl.mem table s then (
					let rw = Hashtbl.find table s in
					add it (LexicalElement.R rw) p
				) else if s = "__asm__" then (
					skip_spaces it;
					let code = Buffer.create 0 in
					while (
						match it.h with
						| '\n' | '\r' | '\x0c' | '\x1a' | ' ' | '\t' | '\x0b' ->
							skip_spaces it;
							Buffer.add_char code ' ';
							true
						| 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' | '(' | ')' | ':' | '.' | ',' ->
							Buffer.add_char code it.h;
							take it;
							true
						| '\"' ->
							let s = read_string it ~quote:'\"' in
							Buffer.add_char code ' ';
							Buffer.add_char code '\"';
							Buffer.add_string code (String.escaped s);
							Buffer.add_char code '\"';
							true
						| ';' -> take it; false
						| _ -> false
					) do () done;
					add it (LexicalElement.Asm (Buffer.contents code)) p
				) else if s = "__attribute__" then (
					skip_spaces it;
					if it.h = '(' then take it else add_error it "\"(\" expected." (current_position it);
					if it.h = '(' then take it else add_error it "\"(\" expected." (current_position it);
					let d = read_word it in
					if it.h = ')' then take it else add_error it "\")\" expected." (current_position it);
					if it.h = ')' then take it else add_error it "\")\" expected." (current_position it);
					add it (LexicalElement.Attribute d) p
				) else if s = "__extension__" then (
					add it (LexicalElement.Extension) p
				) else if s = "__imag__" then (
					add it (LexicalElement.Imag) p
				) else if s = "__inline__" then (
					add it (LexicalElement.R Reserved.INLINE) p
				) else if s = "__int64" then (
					add it (LexicalElement.Int64) p
				) else if s = "__real__" then (
					add it (LexicalElement.Real) p
				) else if s = "__restrict__" then (
					add it (LexicalElement.R Reserved.RESTRICT) p
				) else if s = "__signed" then (
					add it (LexicalElement.R Reserved.SIGNED) p
				) else (
					add it (LexicalElement.I s) p
				)
			| '@' when it.objc ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '\"' ->
					let s = read_string it ~quote:'\"' in
					add it (LexicalElement.ObjC_string_literal s) p
				| 'A'..'Z' | 'a'..'z' ->
					let s = read_word it in
					if Hashtbl.mem Reserved.objcdir_of_string_table s then (
						let d = Hashtbl.find Reserved.objcdir_of_string_table s in
						add it (LexicalElement.ObjC_directive d) p
					) else (
						add_error it ("@" ^ s ^ " is bad directive.") (current_position it)
					)
				| _ ->
					add_error it ("\'@\' is bad character.") (current_position it);
				end
			| '\x1a' ->
				add it LexicalElement.Eof (current_position it)
			| '\n' | '\r'| '\x0c' when it.in_macro ->
				add it LexicalElement.Eof (current_position it)
			| _ ->
				add_unexpected_error it it.h (current_position it);
				take it
			end
		);;
		
	end;;
	open Private;;
	
	let next (it: t): LexicalElement.t * text_file_position = (
		if Queue.is_empty it.tokens then (
			scan it
		);
		Queue.take it.tokens
	);;
	
end;;
